home *** CD-ROM | disk | FTP | other *** search
/ CD ROM Paradise Collection 4 / CD ROM Paradise Collection 4 1995 Nov.iso / program / intrfc70.zip / PARAMS.PAS < prev    next >
Pascal/Delphi Source File  |  1994-03-16  |  4KB  |  146 lines
  1. unit params;
  2. {$I SWITCHES.INC}
  3. interface
  4.   uses dos,globals,util;
  5.  
  6.   procedure syntax_exit(msg:string);
  7.   procedure parse_params;
  8.  
  9. implementation
  10.  
  11. procedure syntax_exit(msg:string);
  12. var
  13.   junk : char;
  14. begin
  15.   {$I-}
  16.   WriteError(msg);
  17.   if textrec(output).handle<>1 then
  18.   begin
  19.     Close(output);
  20.     Assign(output,'CON');
  21.     Rewrite(output);
  22.   end;
  23.   writeln('Syntax:');
  24.   writeln('INTRFC /options unit [output_file]');
  25.   writeln('where options are letters from the following:');
  26.   writeln('B - emitted code bytes');
  27.   writeln('C - initialized constant blocks');
  28.   writeln('D - code blocks');
  29.   writeln('E - routine entry records');
  30.   writeln('G - emitted global const bytes');
  31.   writeln('H - TPU header');
  32.   writeln('I - implementation section (if $D was used in compilation)');
  33.   writeln('L - proc/fn locals (if $L was used in compilation)');
  34.   writeln('M - source line number map');
  35.   writeln('N - names in interface');
  36.   writeln('O - const relocation records');
  37.   writeln('R - relocation records');
  38.   writeln('S - source file records');
  39.   writeln('U - unit list');
  40.   writeln('V - var blocks');
  41.   writeln('W - exported name records');
  42.   writeln('Z - browser section {$Y+}');
  43.   writeln('A - turn all options on');
  44.   write('<Hit Enter for more...>');
  45.   read(junk);
  46.   writeln('Options are processed sequentially and toggle the display.');
  47.   writeln('Use /Tpath[;path] to set the Turbo directory for ',tpl_name);
  48.   writeln(' and referenced units.');
  49.   writeln('E.G. To see all but the relocation records in the system unit, use');
  50.   writeln('   INTRFC /AR /T\bp\bin;\bp\units SYSTEM ');
  51.   writeln('The default is just the names in the interface section.');
  52.   halt(1);
  53. end;
  54.  
  55. procedure toggle(o:option);
  56. begin
  57.   if o in active_options then
  58.     active_options := active_options - [o]
  59.   else
  60.     active_options := active_options + [o];
  61. end;
  62.  
  63. procedure parse_params;
  64. var
  65.   p : string;
  66.   i : integer;
  67.   path : dirstr;
  68.   name : namestr;
  69.  
  70. begin
  71.   i := 1;
  72.   unitname := '';
  73.   uses_path := '';
  74.   for i := 1 to paramcount do
  75.   begin
  76.     p := paramstr(i);
  77.     if p[1] <> '/' then
  78.     begin
  79.       if unitname='' then
  80.       begin
  81.         unitname := upper(p);
  82.         fsplit(unitname,path,name,unit_ext);
  83.         unitname := path+name;
  84.         if unit_ext='' then
  85.           unit_ext:='.TPU';
  86.         if unit_ext='.TPU' then
  87.           tpl_name:='TURBO.TPL'
  88.         else if unit_ext='.TPP' then
  89.           tpl_name:='TPP.TPL'
  90.         else if unit_ext='.TPW' then
  91.           tpl_name:='TPW.TPL'
  92.         else
  93.           HaltError('Invalid extension (TPU,TPP,TPW)');
  94.       end
  95.       else
  96.       begin
  97.         {$I-}
  98.         Close(output);
  99.         Assign(output,p);
  100.         Rewrite(output);
  101.         if IOResult<>0 then
  102.           HaltError('Cannot write to file '+P);
  103.         {$I+}
  104.       end;
  105.     end
  106.     else
  107.     begin
  108.       p := copy(p,2,255);   { strip off the / }
  109.       while length(p) > 0 do
  110.       begin
  111.         case upcase(p[1]) of
  112.         'A' : active_options := [do_header..do_locals];
  113.         'B' : toggle(do_code);
  114.         'C' : toggle(do_const_blocks);
  115.         'D' : toggle(do_code_blocks);
  116.         'E' : toggle(do_entry_pts);
  117.         'G' : toggle(do_const);
  118.         'H' : toggle(do_header);
  119.         'I' : toggle(do_implementation);
  120.         'L' : toggle(do_locals);
  121.         'M' : toggle(do_src_lines);
  122.         'N' : toggle(do_name_list);
  123.         'O' : toggle(do_vmt);
  124.         'R' : toggle(do_reloc);
  125.         'S' : toggle(do_src_files);
  126.         'U' : toggle(do_unit_blocks);
  127.         'V' : toggle(do_var_blocks);
  128.         'W' : toggle(do_dll_blocks);
  129.         'Z' : toggle(do_browser);
  130.         'T' : begin
  131.                 uses_path := upper(copy(p,2,255));
  132.                 p := '';
  133.               end;
  134.         else
  135.           syntax_exit('Unrecognized option '+paramstr(i)+'.');
  136.         end;
  137.         p := copy(p,2,255);
  138.       end;
  139.     end;
  140.   end;
  141.   if unitname = '' then
  142.     syntax_exit('Unit name not specified.');
  143. end;
  144.  
  145. end.
  146.